unit uMemPool;

interface

uses windows;

type

  PMemItem = ^TMemItem;
  TMemItem = record
    Buf: Pointer;
    next: PMemItem;
  end;

  TMemData = record
    Pooled: integer;
    item: PMemItem;
  end;
  PMemData = ^TMemData;

  TMemPool = class
  private
    FSection: TRTLCriticalSection;
    FPageCount: integer;
    FPageSize: integer;
    FMaxPageCount: integer;
    FHead:PMemItem;
    procedure Grow;
    procedure lock;
    procedure unlock;
  public
    constructor Create(APageSize, AMaxPageCount: Integer);
    destructor Destroy; override;
    procedure Pop(var Buf: pointer; size: integer);
    procedure Push(Buf: Pointer);
  end;

implementation

uses SysUtils;

{ TMemPool }

constructor TMemPool.Create(APageSize, AMaxPageCount: Integer);
var
  Sysinfo: TSystemInfo;
begin
  GetSystemInfo(Sysinfo);
  if Sysinfo.dwNumberOfProcessors = 1 then
    InitializeCriticalSection(FSection)
  else
    InitializeCriticalSectionAndSpinCount(FSection, 4000);
  FPageSize := APageSize;
  FMaxPageCount := AMaxPageCount;
end;

destructor TMemPool.Destroy;
var
  FreeCnt:integer;
  item,next:PMemItem;
  B:Pointer;
begin
  FreeCnt:=0;
  item:=FHead;
  while item<>nil do
  begin
     next:=item.next;
     B:=pansichar(item.Buf)-sizeof(tmemdata);
     Dispose(item);
     FreeMem(B);
     inc(FreeCnt);
     item:=next;
  end;
  if FreeCnt<>FPageCount then
    raise Exception.Create('mem not return for all!');
  DeleteCriticalSection(FSection);
  inherited;
end;

procedure TMemPool.Push(Buf: Pointer);
var
  B:pointer;
begin
  B:=Pansichar(Buf)-sizeof(tmemdata);
  if pmemdata(B).Pooled=1 then
  begin
    pmemdata(B).item.next:=FHead;
    FHead:=pmemdata(B).item;
  end
  else
    FreeMem(B);
end;

procedure TMemPool.Pop(var buf: pointer; size: integer);
var
  B:pointer;
begin
  lock;
  if (size > FPageSize)or(FPageCount>=FMaxPageCount) then
  begin
     GetMem(B,size+sizeof(tmemdata));
     PMemData(B).Pooled:=0;
     Buf:=PAnsichar(B)+sizeof(tmemdata);
  end
  else
  begin
     if FHead=nil then
        Grow;
     Buf:=FHead.Buf;
     FHead:=FHead.next;   
  end;
  unlock;
end;

procedure TMemPool.lock;
begin
  EnterCriticalSection(FSection);
end;

procedure TMemPool.unlock;
begin
  LeaveCriticalSection(FSection);
end;

procedure TMemPool.Grow;
var
  prev,item:PMemItem;
  i:integer;
  B:pointer;
begin
  prev:=nil;
  for i:=1 to 256 do
  begin
     New(item);
     item.next:=prev;
     GetMem(B,FPageSize+sizeof(tmemdata));
     PMemData(B).Pooled:=1;
     PMemData(B).item:=item;
     item.Buf:=PAnsichar(B)+sizeof(tmemdata);
     prev:=item;
     inc(FPageCount);
  end;
  FHead:=item;
end;

end.

